home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / harvest.cpt / Harvest C / Tcl 6.2 / tclExpr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-29  |  33.6 KB  |  1,341 lines
  1. #ifdef macintosh
  2. #    pragma segment tclExpr
  3. #endif
  4.  
  5. /* 
  6.  * tclExpr.c --
  7.  *
  8.  *    This file contains the code to evaluate expressions for
  9.  *    Tcl.
  10.  *
  11.  *    This implementation of floating-point support was modelled
  12.  *    after an initial implementation by Bill Carpenter.
  13.  *
  14.  * Copyright 1987-1991 Regents of the University of California
  15.  * Permission to use, copy, modify, and distribute this
  16.  * software and its documentation for any purpose and without
  17.  * fee is hereby granted, provided that the above copyright
  18.  * notice appear in all copies.  The University of California
  19.  * makes no representations about the suitability of this
  20.  * software for any purpose.  It is provided "as is" without
  21.  * express or implied warranty.
  22.  */
  23.  
  24. #ifndef lint
  25. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclExpr.c,v 1.34 91/12/15 17:30:42 ouster Exp $ SPRITE (Berkeley)";
  26. #endif
  27.  
  28. #include "tclInt.h"
  29.  
  30. /*
  31.  * The stuff below is a bit of a hack so that this file can be used
  32.  * in environments that include no UNIX, i.e. no errno.  Just define
  33.  * errno here.
  34.  */
  35.  
  36. #ifndef TCL_GENERIC_ONLY
  37. #include "tclUnix.h"
  38. #else
  39. int errno;
  40. #define ERANGE 34
  41. #endif
  42.  
  43. /*
  44.  * The data structure below is used to describe an expression value,
  45.  * which can be either an integer (the usual case), a double-precision
  46.  * floating-point value, or a string.  A given number has only one
  47.  * value at a time.
  48.  */
  49.  
  50. #define STATIC_STRING_SPACE 150
  51.  
  52. typedef struct {
  53.     long intValue;        /* Integer value, if any. */
  54.     double  doubleValue;    /* Floating-point value, if any. */
  55.     ParseValue pv;        /* Used to hold a string value, if any. */
  56.     char staticSpace[STATIC_STRING_SPACE];
  57.                 /* Storage for small strings;  large ones
  58.                  * are malloc-ed. */
  59.     int type;            /* Type of value:  TYPE_INT, TYPE_DOUBLE,
  60.                  * or TYPE_STRING. */
  61. } Value;
  62.  
  63. /*
  64.  * Valid values for type:
  65.  */
  66.  
  67. #define TYPE_INT    0
  68. #define TYPE_DOUBLE    1
  69. #define TYPE_STRING    2
  70.  
  71.  
  72. /*
  73.  * The data structure below describes the state of parsing an expression.
  74.  * It's passed among the routines in this module.
  75.  */
  76.  
  77. typedef struct {
  78.     char *originalExpr;        /* The entire expression, as originally
  79.                  * passed to Tcl_Expr. */
  80.     char *expr;            /* Position to the next character to be
  81.                  * scanned from the expression string. */
  82.     int token;            /* Type of the last token to be parsed from
  83.                  * expr.  See below for definitions.
  84.                  * Corresponds to the characters just
  85.                  * before expr. */
  86. } ExprInfo;
  87.  
  88. /*
  89.  * The token types are defined below.  In addition, there is a table
  90.  * associating a precedence with each operator.  The order of types
  91.  * is important.  Consult the code before changing it.
  92.  */
  93.  
  94. #define VALUE        0
  95. #define OPEN_PAREN    1
  96. #define CLOSE_PAREN    2
  97. #define END        3
  98. #define UNKNOWN        4
  99.  
  100. /*
  101.  * Binary operators:
  102.  */
  103.  
  104. #define MULT        8
  105. #define DIVIDE        9
  106. #define MOD        10
  107. #define PLUS        11
  108. #define MINUS        12
  109. #define LEFT_SHIFT    13
  110. #define RIGHT_SHIFT    14
  111. #define LESS        15
  112. #define GREATER        16
  113. #define LEQ        17
  114. #define GEQ        18
  115. #define EQUAL        19
  116. #define NEQ        20
  117. #define BIT_AND        21
  118. #define BIT_XOR        22
  119. #define BIT_OR        23
  120. #define AND        24
  121. #define OR        25
  122. #define QUESTY        26
  123. #define COLON        27
  124.  
  125. /*
  126.  * Unary operators:
  127.  */
  128.  
  129. #define    UNARY_MINUS    28
  130. #define NOT        29
  131. #define BIT_NOT        30
  132.  
  133. /*
  134.  * Precedence table.  The values for non-operator token types are ignored.
  135.  */
  136.  
  137. int precTable[] = {
  138.     0, 0, 0, 0, 0, 0, 0, 0,
  139.     11, 11, 11,                /* MULT, DIVIDE, MOD */
  140.     10, 10,                /* PLUS, MINUS */
  141.     9, 9,                /* LEFT_SHIFT, RIGHT_SHIFT */
  142.     8, 8, 8, 8,                /* LESS, GREATER, LEQ, GEQ */
  143.     7, 7,                /* EQUAL, NEQ */
  144.     6,                    /* BIT_AND */
  145.     5,                    /* BIT_XOR */
  146.     4,                    /* BIT_OR */
  147.     3,                    /* AND */
  148.     2,                    /* OR */
  149.     1, 1,                /* QUESTY, COLON */
  150.     12, 12, 12                /* UNARY_MINUS, NOT, BIT_NOT */
  151. };
  152.  
  153. /*
  154.  * Mapping from operator numbers to strings;  used for error messages.
  155.  */
  156.  
  157. char *operatorStrings[] = {
  158.     "VALUE", "(", ")", "END", "UNKNOWN", "5", "6", "7",
  159.     "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=",
  160.     ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":",
  161.     "-", "!", "~"
  162. };
  163.  
  164. /*
  165.  * Declarations for local procedures to this file:
  166.  */
  167.  
  168. static int        ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp,
  169.                 ExprInfo *infoPtr, int prec, Value *valuePtr));
  170. static int        ExprLex _ANSI_ARGS_((Tcl_Interp *interp,
  171.                 ExprInfo *infoPtr, Value *valuePtr));
  172. static void        ExprMakeString _ANSI_ARGS_((Value *valuePtr));
  173. static int        ExprParseString _ANSI_ARGS_((Tcl_Interp *interp,
  174.                 char *string, Value *valuePtr));
  175. static int        ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp,
  176.                 char *string, Value *valuePtr));
  177.  
  178. /*
  179.  *--------------------------------------------------------------
  180.  *
  181.  * ExprParseString --
  182.  *
  183.  *    Given a string (such as one coming from command or variable
  184.  *    substitution), make a Value based on the string.  The value
  185.  *    will be a floating-point or integer, if possible, or else it
  186.  *    will just be a copy of the string.
  187.  *
  188.  * Results:
  189.  *    TCL_OK is returned under normal circumstances, and TCL_ERROR
  190.  *    is returned if a floating-point overflow or underflow occurred
  191.  *    while reading in a number.  The value at *valuePtr is modified
  192.  *    to hold a number, if possible.
  193.  *
  194.  * Side effects:
  195.  *    None.
  196.  *
  197.  *--------------------------------------------------------------
  198.  */
  199.  
  200. static int
  201. ExprParseString(interp, string, valuePtr)
  202.     Tcl_Interp *interp;        /* Where to store error message. */
  203.     char *string;        /* String to turn into value. */
  204.     Value *valuePtr;        /* Where to store value information. 
  205.                  * Caller must have initialized pv field. */
  206. {
  207.     register char c;
  208.  
  209.     /*
  210.      * Try to convert the string to a number.
  211.      */
  212.  
  213.     c = *string;
  214.     if (((c >= '0') && (c <= '9')) || (c == '-')) {
  215.     char *term;
  216.  
  217.     valuePtr->type = TYPE_INT;
  218.     errno = 0;
  219.     valuePtr->intValue = strtol(string, &term, 0);
  220.     c = *term;
  221.     if ((c == '\0') && (errno != ERANGE)) {
  222.         return TCL_OK;
  223.     }
  224.     if ((c == '.') || (c == 'e') || (c == 'E') || (errno == ERANGE)) {
  225.         errno = 0;
  226.         valuePtr->doubleValue = strtod(string, &term);
  227.         if (errno == ERANGE) {
  228.         Tcl_ResetResult(interp);
  229.         if (valuePtr->doubleValue == 0.0) {
  230.             Tcl_AppendResult(interp, "floating-point value \"",
  231.                 string, "\" too small to represent",
  232.                 (char *) NULL);
  233.         } else {
  234.             Tcl_AppendResult(interp, "floating-point value \"",
  235.                 string, "\" too large to represent",
  236.                 (char *) NULL);
  237.         }
  238.         return TCL_ERROR;
  239.         }
  240.         if (*term == '\0') {
  241.         valuePtr->type = TYPE_DOUBLE;
  242.         return TCL_OK;
  243.         }
  244.     }
  245.     }
  246.  
  247.     /*
  248.      * Not a valid number.  Save a string value (but don't do anything
  249.      * if it's already the value).
  250.      */
  251.  
  252.     valuePtr->type = TYPE_STRING;
  253.     if (string != valuePtr->pv.buffer) {
  254.     int length, shortfall;
  255.  
  256.     length = strlen(string);
  257.     valuePtr->pv.next = valuePtr->pv.buffer;
  258.     shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer);
  259.     if (shortfall > 0) {
  260.         (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
  261.     }
  262.     strcpy(valuePtr->pv.buffer, string);
  263.     }
  264.     return TCL_OK;
  265. }
  266.  
  267. /*
  268.  *----------------------------------------------------------------------
  269.  *
  270.  * ExprLex --
  271.  *
  272.  *    Lexical analyzer for expression parser:  parses a single value,
  273.  *    operator, or other syntactic element from an expression string.
  274.  *
  275.  * Results:
  276.  *    TCL_OK is returned unless an error occurred while doing lexical
  277.  *    analysis or executing an embedded command.  In that case a
  278.  *    standard Tcl error is returned, using interp->result to hold
  279.  *    an error message.  In the event of a successful return, the token
  280.  *    and field in infoPtr is updated to refer to the next symbol in
  281.  *    the expression string, and the expr field is advanced past that
  282.  *    token;  if the token is a value, then the value is stored at
  283.  *    valuePtr.
  284.  *
  285.  * Side effects:
  286.  *    None.
  287.  *
  288.  *----------------------------------------------------------------------
  289.  */
  290.  
  291. static int
  292. ExprLex(interp, infoPtr, valuePtr)
  293.     Tcl_Interp *interp;            /* Interpreter to use for error
  294.                      * reporting. */
  295.     register ExprInfo *infoPtr;        /* Describes the state of the parse. */
  296.     register Value *valuePtr;        /* Where to store value, if that is
  297.                      * what's parsed from string.  Caller
  298.                      * must have initialized pv field
  299.                      * correctly. */
  300. {
  301.     register char *p, c;
  302.     char *var, *term;
  303.     int result;
  304.  
  305.     p = infoPtr->expr;
  306.     c = *p;
  307.     while (isspace(c)) {
  308.     p++;
  309.     c = *p;
  310.     }
  311.     infoPtr->expr = p+1;
  312.     switch (c) {
  313.     case '0':
  314.     case '1':
  315.     case '2':
  316.     case '3':
  317.     case '4':
  318.     case '5':
  319.     case '6':
  320.     case '7':
  321.     case '8':
  322.     case '9':
  323.     case '.':
  324.  
  325.         /*
  326.          * Number.  First read an integer.  Then if it looks like
  327.          * there's a floating-point number (or if it's too big a
  328.          * number to fit in an integer), parse it as a floating-point
  329.          * number.
  330.          */
  331.  
  332.         infoPtr->token = VALUE;
  333.         valuePtr->type = TYPE_INT;
  334.         errno = 0;
  335.         valuePtr->intValue = strtoul(p, &term, 0);
  336.         c = *term;
  337.         if ((c == '.') || (c == 'e') || (c == 'E') || (errno == ERANGE)) {
  338.         char *term2;
  339.  
  340.         errno = 0;
  341.         valuePtr->doubleValue = strtod(p, &term2);
  342.         if (errno == ERANGE) {
  343.             Tcl_ResetResult(interp);
  344.             if (valuePtr->doubleValue == 0.0) {
  345.             interp->result =
  346.                 "floating-point value too small to represent";
  347.             } else {
  348.             interp->result =
  349.                 "floating-point value too large to represent";
  350.             }
  351.             return TCL_ERROR;
  352.         }
  353.         if (term2 == infoPtr->expr) {
  354.             interp->result = "poorly-formed floating-point value";
  355.             return TCL_ERROR;
  356.         }
  357.         valuePtr->type = TYPE_DOUBLE;
  358.         infoPtr->expr = term2;
  359.         } else {
  360.         infoPtr->expr = term;
  361.         }
  362.         return TCL_OK;
  363.  
  364.     case '$':
  365.  
  366.         /*
  367.          * Variable.  Fetch its value, then see if it makes sense
  368.          * as an integer or floating-point number.
  369.          */
  370.  
  371.         infoPtr->token = VALUE;
  372.         var = Tcl_ParseVar(interp, p, &infoPtr->expr);
  373.         if (var == NULL) {
  374.         return TCL_ERROR;
  375.         }
  376.         if (((Interp *) interp)->noEval) {
  377.         valuePtr->type = TYPE_INT;
  378.         valuePtr->intValue = 0;
  379.         return TCL_OK;
  380.         }
  381.         return ExprParseString(interp, var, valuePtr);
  382.  
  383.     case '[':
  384.         infoPtr->token = VALUE;
  385.         result = Tcl_Eval(interp, p+1, TCL_BRACKET_TERM,
  386.             &infoPtr->expr);
  387.         if (result != TCL_OK) {
  388.         return result;
  389.         }
  390.         infoPtr->expr++;
  391.         if (((Interp *) interp)->noEval) {
  392.         valuePtr->type = TYPE_INT;
  393.         valuePtr->intValue = 0;
  394.         Tcl_ResetResult(interp);
  395.         return TCL_OK;
  396.         }
  397.         result = ExprParseString(interp, interp->result, valuePtr);
  398.         if (result != TCL_OK) {
  399.         return result;
  400.         }
  401.         Tcl_ResetResult(interp);
  402.         return TCL_OK;
  403.  
  404.     case '"':
  405.         infoPtr->token = VALUE;
  406.         result = TclParseQuotes(interp, infoPtr->expr, '"', 0,
  407.             &infoPtr->expr, &valuePtr->pv);
  408.         if (result != TCL_OK) {
  409.         return result;
  410.         }
  411.         return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
  412.  
  413.     case '{':
  414.         infoPtr->token = VALUE;
  415.         result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr,
  416.             &valuePtr->pv);
  417.         if (result != TCL_OK) {
  418.         return result;
  419.         }
  420.         return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
  421.  
  422.     case '(':
  423.         infoPtr->token = OPEN_PAREN;
  424.         return TCL_OK;
  425.  
  426.     case ')':
  427.         infoPtr->token = CLOSE_PAREN;
  428.         return TCL_OK;
  429.  
  430.     case '*':
  431.         infoPtr->token = MULT;
  432.         return TCL_OK;
  433.  
  434.     case '/':
  435.         infoPtr->token = DIVIDE;
  436.         return TCL_OK;
  437.  
  438.     case '%':
  439.         infoPtr->token = MOD;
  440.         return TCL_OK;
  441.  
  442.     case '+':
  443.         infoPtr->token = PLUS;
  444.         return TCL_OK;
  445.  
  446.     case '-':
  447.         infoPtr->token = MINUS;
  448.         return TCL_OK;
  449.  
  450.     case '?':
  451.         infoPtr->token = QUESTY;
  452.         return TCL_OK;
  453.  
  454.     case ':':
  455.         infoPtr->token = COLON;
  456.         return TCL_OK;
  457.  
  458.     case '<':
  459.         switch (p[1]) {
  460.         case '<':
  461.             infoPtr->expr = p+2;
  462.             infoPtr->token = LEFT_SHIFT;
  463.             break;
  464.         case '=':
  465.             infoPtr->expr = p+2;
  466.             infoPtr->token = LEQ;
  467.             break;
  468.         default:
  469.             infoPtr->token = LESS;
  470.             break;
  471.         }
  472.         return TCL_OK;
  473.  
  474.     case '>':
  475.         switch (p[1]) {
  476.         case '>':
  477.             infoPtr->expr = p+2;
  478.             infoPtr->token = RIGHT_SHIFT;
  479.             break;
  480.         case '=':
  481.             infoPtr->expr = p+2;
  482.             infoPtr->token = GEQ;
  483.             break;
  484.         default:
  485.             infoPtr->token = GREATER;
  486.             break;
  487.         }
  488.         return TCL_OK;
  489.  
  490.     case '=':
  491.         if (p[1] == '=') {
  492.         infoPtr->expr = p+2;
  493.         infoPtr->token = EQUAL;
  494.         } else {
  495.         infoPtr->token = UNKNOWN;
  496.         }
  497.         return TCL_OK;
  498.  
  499.     case '!':
  500.         if (p[1] == '=') {
  501.         infoPtr->expr = p+2;
  502.         infoPtr->token = NEQ;
  503.         } else {
  504.         infoPtr->token = NOT;
  505.         }
  506.         return TCL_OK;
  507.  
  508.     case '&':
  509.         if (p[1] == '&') {
  510.         infoPtr->expr = p+2;
  511.         infoPtr->token = AND;
  512.         } else {
  513.         infoPtr->token = BIT_AND;
  514.         }
  515.         return TCL_OK;
  516.  
  517.     case '^':
  518.         infoPtr->token = BIT_XOR;
  519.         return TCL_OK;
  520.  
  521.     case '|':
  522.         if (p[1] == '|') {
  523.         infoPtr->expr = p+2;
  524.         infoPtr->token = OR;
  525.         } else {
  526.         infoPtr->token = BIT_OR;
  527.         }
  528.         return TCL_OK;
  529.  
  530.     case '~':
  531.         infoPtr->token = BIT_NOT;
  532.         return TCL_OK;
  533.  
  534.     case 0:
  535.         infoPtr->token = END;
  536.         infoPtr->expr = p;
  537.         return TCL_OK;
  538.  
  539.     default:
  540.         infoPtr->expr = p+1;
  541.         infoPtr->token = UNKNOWN;
  542.         return TCL_OK;
  543.     }
  544. }
  545.  
  546. /*
  547.  *----------------------------------------------------------------------
  548.  *
  549.  * ExprGetValue --
  550.  *
  551.  *    Parse a "value" from the remainder of the expression in infoPtr.
  552.  *
  553.  * Results:
  554.  *    Normally TCL_OK is returned.  The value of the expression is
  555.  *    returned in *valuePtr.  If an error occurred, then interp->result
  556.  *    contains an error message and TCL_ERROR is returned.
  557.  *    InfoPtr->token will be left pointing to the token AFTER the
  558.  *    expression, and infoPtr->expr will point to the character just
  559.  *    after the terminating token.
  560.  *
  561.  * Side effects:
  562.  *    None.
  563.  *
  564.  *----------------------------------------------------------------------
  565.  */
  566.  
  567. static int
  568. ExprGetValue(interp, infoPtr, prec, valuePtr)
  569.     Tcl_Interp *interp;            /* Interpreter to use for error
  570.                      * reporting. */
  571.     register ExprInfo *infoPtr;        /* Describes the state of the parse
  572.                      * just before the value (i.e. ExprLex
  573.                      * will be called to get first token
  574.                      * of value). */
  575.     int prec;                /* Treat any un-parenthesized operator
  576.                      * with precedence <= this as the end
  577.                      * of the expression. */
  578.     Value *valuePtr;            /* Where to store the value of the
  579.                      * expression.   Caller must have
  580.                      * initialized pv field. */
  581. {
  582.     Interp *iPtr = (Interp *) interp;
  583.     Value value2;            /* Second operand for current
  584.                      * operator.  */
  585.     int operator;            /* Current operator (either unary
  586.                      * or binary). */
  587.     int badType;            /* Type of offending argument;  used
  588.                      * for error messages. */
  589.     int gotOp;                /* Non-zero means already lexed the
  590.                      * operator (while picking up value
  591.                      * for unary operator).  Don't lex
  592.                      * again. */
  593.     int result;
  594.  
  595.     /*
  596.      * There are two phases to this procedure.  First, pick off an initial
  597.      * value.  Then, parse (binary operator, value) pairs until done.
  598.      */
  599.  
  600.     gotOp = 0;
  601.     value2.pv.buffer = value2.pv.next = value2.staticSpace;
  602.     value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1;
  603.     value2.pv.expandProc = TclExpandParseValue;
  604.     value2.pv.clientData = (ClientData) NULL;
  605.     result = ExprLex(interp, infoPtr, valuePtr);
  606.     if (result != TCL_OK) {
  607.     goto done;
  608.     }
  609.     if (infoPtr->token == OPEN_PAREN) {
  610.  
  611.     /*
  612.      * Parenthesized sub-expression.
  613.      */
  614.  
  615.     result = ExprGetValue(interp, infoPtr, -1, valuePtr);
  616.     if (result != TCL_OK) {
  617.         goto done;
  618.     }
  619.     if (infoPtr->token != CLOSE_PAREN) {
  620.         Tcl_ResetResult(interp);
  621.         sprintf(interp->result,
  622.             "unmatched parentheses in expression \"%.50s\"",
  623.             infoPtr->originalExpr);
  624.         result = TCL_ERROR;
  625.         goto done;
  626.     }
  627.     } else {
  628.     if (infoPtr->token == MINUS) {
  629.         infoPtr->token = UNARY_MINUS;
  630.     }
  631.     if (infoPtr->token >= UNARY_MINUS) {
  632.  
  633.         /*
  634.          * Process unary operators.
  635.          */
  636.  
  637.         operator = infoPtr->token;
  638.         result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token],
  639.             valuePtr);
  640.         if (result != TCL_OK) {
  641.         goto done;
  642.         }
  643.         switch (operator) {
  644.         case UNARY_MINUS:
  645.             if (valuePtr->type == TYPE_INT) {
  646.             valuePtr->intValue = -valuePtr->intValue;
  647.             } else if (valuePtr->type == TYPE_DOUBLE){
  648.             valuePtr->doubleValue = -valuePtr->doubleValue;
  649.             } else {
  650.             badType = valuePtr->type;
  651.             goto illegalType;
  652.             } 
  653.             break;
  654.         case NOT:
  655.             if (valuePtr->type == TYPE_INT) {
  656.             valuePtr->intValue = !valuePtr->intValue;
  657.             } else if (valuePtr->type == TYPE_DOUBLE) {
  658.             /*
  659.              * Theoretically, should be able to use
  660.              * "!valuePtr->intValue", but apparently some
  661.              * compilers can't handle it.
  662.              */
  663.             if (valuePtr->doubleValue == 0.0) {
  664.                 valuePtr->intValue = 1;
  665.             } else {
  666.                 valuePtr->intValue = 0;
  667.             }
  668.             valuePtr->type = TYPE_INT;
  669.             } else {
  670.             badType = valuePtr->type;
  671.             goto illegalType;
  672.             }
  673.             break;
  674.         case BIT_NOT:
  675.             if (valuePtr->type == TYPE_INT) {
  676.             valuePtr->intValue = ~valuePtr->intValue;
  677.             } else {
  678.             badType  = valuePtr->type;
  679.             goto illegalType;
  680.             }
  681.             break;
  682.         }
  683.         gotOp = 1;
  684.     } else if (infoPtr->token != VALUE) {
  685.         goto syntaxError;
  686.     }
  687.     }
  688.  
  689.     /*
  690.      * Got the first operand.  Now fetch (operator, operand) pairs.
  691.      */
  692.  
  693.     if (!gotOp) {
  694.     result = ExprLex(interp, infoPtr, &value2);
  695.     if (result != TCL_OK) {
  696.         goto done;
  697.     }
  698.     }
  699.     while (1) {
  700.     operator = infoPtr->token;
  701.     value2.pv.next = value2.pv.buffer;
  702.     if ((operator < MULT) || (operator >= UNARY_MINUS)) {
  703.         if ((operator == END) || (operator == CLOSE_PAREN)) {
  704.         result = TCL_OK;
  705.         goto done;
  706.         } else {
  707.         goto syntaxError;
  708.         }
  709.     }
  710.     if (precTable[operator] <= prec) {
  711.         result = TCL_OK;
  712.         goto done;
  713.     }
  714.  
  715.     /*
  716.      * If we're doing an AND or OR and the first operand already
  717.      * determines the result, don't execute anything in the
  718.      * second operand:  just parse.  Same style for ?: pairs.
  719.      */
  720.  
  721.     if ((operator == AND) || (operator == OR) || (operator == QUESTY)) {
  722.         if (valuePtr->type == TYPE_DOUBLE) {
  723.         valuePtr->intValue = valuePtr->doubleValue != 0;
  724.         valuePtr->type = TYPE_INT;
  725.         } else if (valuePtr->type == TYPE_STRING) {
  726.         badType = TYPE_STRING;
  727.         goto illegalType;
  728.         }
  729.         if (((operator == AND) && !valuePtr->intValue)
  730.             || ((operator == OR) && valuePtr->intValue)) {
  731.         iPtr->noEval++;
  732.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  733.             &value2);
  734.         iPtr->noEval--;
  735.         } else if (operator == QUESTY) {
  736.         if (valuePtr->intValue != 0) {
  737.             valuePtr->pv.next = valuePtr->pv.buffer;
  738.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  739.                 valuePtr);
  740.             if (result != TCL_OK) {
  741.             goto done;
  742.             }
  743.             if (infoPtr->token != COLON) {
  744.             goto syntaxError;
  745.             }
  746.             value2.pv.next = value2.pv.buffer;
  747.             iPtr->noEval++;
  748.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  749.                 &value2);
  750.             iPtr->noEval--;
  751.         } else {
  752.             iPtr->noEval++;
  753.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  754.                 &value2);
  755.             iPtr->noEval--;
  756.             if (result != TCL_OK) {
  757.             goto done;
  758.             }
  759.             if (infoPtr->token != COLON) {
  760.             goto syntaxError;
  761.             }
  762.             valuePtr->pv.next = valuePtr->pv.buffer;
  763.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  764.                 valuePtr);
  765.         }
  766.         } else {
  767.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  768.             &value2);
  769.         }
  770.     } else {
  771.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  772.             &value2);
  773.     }
  774.     if (result != TCL_OK) {
  775.         goto done;
  776.     }
  777.     if ((infoPtr->token < MULT) && (infoPtr->token != VALUE)
  778.         && (infoPtr->token != END)
  779.         && (infoPtr->token != CLOSE_PAREN)) {
  780.         goto syntaxError;
  781.     }
  782.  
  783.     /*
  784.      * At this point we've got two values and an operator.  Check
  785.      * to make sure that the particular data types are appropriate
  786.      * for the particular operator, and perform type conversion
  787.      * if necessary.
  788.      */
  789.  
  790.     switch (operator) {
  791.  
  792.         /*
  793.          * For the operators below, no strings are allowed and
  794.          * ints get converted to floats if necessary.
  795.          */
  796.  
  797.         case MULT: case DIVIDE: case PLUS: case MINUS:
  798.         if ((valuePtr->type == TYPE_STRING)
  799.             || (value2.type == TYPE_STRING)) {
  800.             badType = TYPE_STRING;
  801.             goto illegalType;
  802.         }
  803.         if (valuePtr->type == TYPE_DOUBLE) {
  804.             if (value2.type == TYPE_INT) {
  805.             value2.doubleValue = value2.intValue;
  806.             value2.type = TYPE_DOUBLE;
  807.             }
  808.         } else if (value2.type == TYPE_DOUBLE) {
  809.             if (valuePtr->type == TYPE_INT) {
  810.             valuePtr->doubleValue = valuePtr->intValue;
  811.             valuePtr->type = TYPE_DOUBLE;
  812.             }
  813.         }
  814.         break;
  815.  
  816.         /*
  817.          * For the operators below, only integers are allowed.
  818.          */
  819.  
  820.         case MOD: case LEFT_SHIFT: case RIGHT_SHIFT:
  821.         case BIT_AND: case BIT_XOR: case BIT_OR:
  822.          if (valuePtr->type != TYPE_INT) {
  823.              badType = valuePtr->type;
  824.              goto illegalType;
  825.          } else if (value2.type != TYPE_INT) {
  826.              badType = value2.type;
  827.              goto illegalType;
  828.          }
  829.          break;
  830.  
  831.         /*
  832.          * For the operators below, any type is allowed but the
  833.          * two operands must have the same type.  Convert integers
  834.          * to floats and either to strings, if necessary.
  835.          */
  836.  
  837.         case LESS: case GREATER: case LEQ: case GEQ:
  838.         case EQUAL: case NEQ:
  839.         if (valuePtr->type == TYPE_STRING) {
  840.             if (value2.type != TYPE_STRING) {
  841.             ExprMakeString(&value2);
  842.             }
  843.         } else if (value2.type == TYPE_STRING) {
  844.             if (valuePtr->type != TYPE_STRING) {
  845.             ExprMakeString(valuePtr);
  846.             }
  847.         } else if (valuePtr->type == TYPE_DOUBLE) {
  848.             if (value2.type == TYPE_INT) {
  849.             value2.doubleValue = value2.intValue;
  850.             value2.type = TYPE_DOUBLE;
  851.             }
  852.         } else if (value2.type == TYPE_DOUBLE) {
  853.              if (valuePtr->type == TYPE_INT) {
  854.             valuePtr->doubleValue = valuePtr->intValue;
  855.             valuePtr->type = TYPE_DOUBLE;
  856.             }
  857.         }
  858.         break;
  859.  
  860.         /*
  861.          * For the operators below, no strings are allowed, but
  862.          * no int->double conversions are performed.
  863.          */
  864.  
  865.         case AND: case OR:
  866.         if (valuePtr->type == TYPE_STRING) {
  867.             badType = valuePtr->type;
  868.             goto illegalType;
  869.         }
  870.         if (value2.type == TYPE_STRING) {
  871.             badType = value2.type;
  872.             goto illegalType;
  873.         }
  874.         break;
  875.  
  876.         /*
  877.          * For the operators below, type and conversions are
  878.          * irrelevant:  they're handled elsewhere.
  879.          */
  880.  
  881.         case QUESTY: case COLON:
  882.         break;
  883.  
  884.         /*
  885.          * Any other operator is an error.
  886.          */
  887.  
  888.         default:
  889.         interp->result = "unknown operator in expression";
  890.         result = TCL_ERROR;
  891.         goto done;
  892.     }
  893.  
  894.     /*
  895.      * If necessary, convert one of the operands to the type
  896.      * of the other.  If the operands are incompatible with
  897.      * the operator (e.g. "+" on strings) then return an
  898.      * error.
  899.      */
  900.  
  901.     switch (operator) {
  902.         case MULT:
  903.         if (valuePtr->type == TYPE_INT) {
  904.             valuePtr->intValue *= value2.intValue;
  905.         } else {
  906.             valuePtr->doubleValue *= value2.doubleValue;
  907.         }
  908.         break;
  909.         case DIVIDE:
  910.         if (valuePtr->type == TYPE_INT) {
  911.             if (value2.intValue == 0) {
  912.             divideByZero:
  913.             interp->result = "divide by zero";
  914.             result = TCL_ERROR;
  915.             goto done;
  916.             }
  917.             valuePtr->intValue /= value2.intValue;
  918.         } else {
  919.             if (value2.doubleValue == 0.0) {
  920.             goto divideByZero;
  921.             }
  922.             valuePtr->doubleValue /= value2.doubleValue;
  923.         }
  924.         break;
  925.         case MOD:
  926.         if (value2.intValue == 0) {
  927.             goto divideByZero;
  928.         }
  929.         valuePtr->intValue %= value2.intValue;
  930.         break;
  931.         case PLUS:
  932.         if (valuePtr->type == TYPE_INT) {
  933.             valuePtr->intValue += value2.intValue;
  934.         } else {
  935.             valuePtr->doubleValue += value2.doubleValue;
  936.         }
  937.         break;
  938.         case MINUS:
  939.         if (valuePtr->type == TYPE_INT) {
  940.             valuePtr->intValue -= value2.intValue;
  941.         } else {
  942.             valuePtr->doubleValue -= value2.doubleValue;
  943.         }
  944.         break;
  945.         case LEFT_SHIFT:
  946.         valuePtr->intValue <<= value2.intValue;
  947.         break;
  948.         case RIGHT_SHIFT:
  949.         /*
  950.          * The following code is a bit tricky:  it ensures that
  951.          * right shifts propagate the sign bit even on machines
  952.          * where ">>" won't do it by default.
  953.          */
  954.  
  955.         if (valuePtr->intValue < 0) {
  956.             valuePtr->intValue =
  957.                 ~((~valuePtr->intValue) >> value2.intValue);
  958.         } else {
  959.             valuePtr->intValue >>= value2.intValue;
  960.         }
  961.         break;
  962.         case LESS:
  963.         if (valuePtr->type == TYPE_INT) {
  964.             valuePtr->intValue =
  965.             valuePtr->intValue < value2.intValue;
  966.         } else if (valuePtr->type == TYPE_DOUBLE) {
  967.             valuePtr->intValue =
  968.             valuePtr->doubleValue < value2.doubleValue;
  969.         } else {
  970.             valuePtr->intValue =
  971.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0;
  972.         }
  973.         valuePtr->type = TYPE_INT;
  974.         break;
  975.         case GREATER:
  976.         if (valuePtr->type == TYPE_INT) {
  977.             valuePtr->intValue =
  978.             valuePtr->intValue > value2.intValue;
  979.         } else if (valuePtr->type == TYPE_DOUBLE) {
  980.             valuePtr->intValue =
  981.             valuePtr->doubleValue > value2.doubleValue;
  982.         } else {
  983.             valuePtr->intValue =
  984.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0;
  985.         }
  986.         valuePtr->type = TYPE_INT;
  987.         break;
  988.         case LEQ:
  989.         if (valuePtr->type == TYPE_INT) {
  990.             valuePtr->intValue =
  991.             valuePtr->intValue <= value2.intValue;
  992.         } else if (valuePtr->type == TYPE_DOUBLE) {
  993.             valuePtr->intValue =
  994.             valuePtr->doubleValue <= value2.doubleValue;
  995.         } else {
  996.             valuePtr->intValue =
  997.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0;
  998.         }
  999.         valuePtr->type = TYPE_INT;
  1000.         break;
  1001.         case GEQ:
  1002.         if (valuePtr->type == TYPE_INT) {
  1003.             valuePtr->intValue =
  1004.             valuePtr->intValue >= value2.intValue;
  1005.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1006.             valuePtr->intValue =
  1007.             valuePtr->doubleValue >= value2.doubleValue;
  1008.         } else {
  1009.             valuePtr->intValue =
  1010.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0;
  1011.         }
  1012.         valuePtr->type = TYPE_INT;
  1013.         break;
  1014.         case EQUAL:
  1015.         if (valuePtr->type == TYPE_INT) {
  1016.             valuePtr->intValue =
  1017.             valuePtr->intValue == value2.intValue;
  1018.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1019.             valuePtr->intValue =
  1020.             valuePtr->doubleValue == value2.doubleValue;
  1021.         } else {
  1022.             valuePtr->intValue =
  1023.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0;
  1024.         }
  1025.         valuePtr->type = TYPE_INT;
  1026.         break;
  1027.         case NEQ:
  1028.         if (valuePtr->type == TYPE_INT) {
  1029.             valuePtr->intValue =
  1030.             valuePtr->intValue != value2.intValue;
  1031.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1032.             valuePtr->intValue =
  1033.             valuePtr->doubleValue != value2.doubleValue;
  1034.         } else {
  1035.             valuePtr->intValue =
  1036.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0;
  1037.         }
  1038.         valuePtr->type = TYPE_INT;
  1039.         break;
  1040.         case BIT_AND:
  1041.         valuePtr->intValue &= value2.intValue;
  1042.         break;
  1043.         case BIT_XOR:
  1044.         valuePtr->intValue ^= value2.intValue;
  1045.         break;
  1046.         case BIT_OR:
  1047.         valuePtr->intValue |= value2.intValue;
  1048.         break;
  1049.  
  1050.         /*
  1051.          * For AND and OR, we know that the first value has already
  1052.          * been converted to an integer.  Thus we need only consider
  1053.          * the possibility of int vs. double for the second value.
  1054.          */
  1055.  
  1056.         case AND:
  1057.         if (value2.type == TYPE_DOUBLE) {
  1058.             value2.intValue = value2.doubleValue != 0;
  1059.             value2.type = TYPE_INT;
  1060.         }
  1061.         valuePtr->intValue = valuePtr->intValue && value2.intValue;
  1062.         break;
  1063.         case OR:
  1064.         if (value2.type == TYPE_DOUBLE) {
  1065.             value2.intValue = value2.doubleValue != 0;
  1066.             value2.type = TYPE_INT;
  1067.         }
  1068.         valuePtr->intValue = valuePtr->intValue || value2.intValue;
  1069.         break;
  1070.  
  1071.         case COLON:
  1072.         interp->result = "can't have : operator without ? first";
  1073.         result = TCL_ERROR;
  1074.         goto done;
  1075.     }
  1076.     }
  1077.  
  1078.     done:
  1079.     if (value2.pv.buffer != value2.staticSpace) {
  1080.     ckfree(value2.pv.buffer);
  1081.     }
  1082.     return result;
  1083.  
  1084.     syntaxError:
  1085.     Tcl_ResetResult(interp);
  1086.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1087.         infoPtr->originalExpr, "\"", (char *) NULL);
  1088.     result = TCL_ERROR;
  1089.     goto done;
  1090.  
  1091.     illegalType:
  1092.     Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ?
  1093.         "floating-point value" : "non-numeric string",
  1094.         " as operand of \"", operatorStrings[operator], "\"",
  1095.         (char *) NULL);
  1096.     result = TCL_ERROR;
  1097.     goto done;
  1098. }
  1099.  
  1100. /*
  1101.  *--------------------------------------------------------------
  1102.  *
  1103.  * ExprMakeString --
  1104.  *
  1105.  *    Convert a value from int or double representation to
  1106.  *    a string.
  1107.  *
  1108.  * Results:
  1109.  *    The information at *valuePtr gets converted to string
  1110.  *    format, if it wasn't that way already.
  1111.  *
  1112.  * Side effects:
  1113.  *    None.
  1114.  *
  1115.  *--------------------------------------------------------------
  1116.  */
  1117.  
  1118. static void
  1119. ExprMakeString(valuePtr)
  1120.     register Value *valuePtr;        /* Value to be converted. */
  1121. {
  1122.     int shortfall;
  1123.  
  1124.     shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer);
  1125.     if (shortfall > 0) {
  1126.     (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
  1127.     }
  1128.     if (valuePtr->type == TYPE_INT) {
  1129.     sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue);
  1130.     } else if (valuePtr->type == TYPE_DOUBLE) {
  1131.     sprintf(valuePtr->pv.buffer, "%g", valuePtr->doubleValue);
  1132.     }
  1133.     valuePtr->type = TYPE_STRING;
  1134. }
  1135.  
  1136. /*
  1137.  *--------------------------------------------------------------
  1138.  *
  1139.  * ExprTopLevel --
  1140.  *
  1141.  *    This procedure provides top-level functionality shared by
  1142.  *    procedures like Tcl_ExprInt, Tcl_ExprDouble, etc.
  1143.  *
  1144.  * Results:
  1145.  *    The result is a standard Tcl return value.  If an error
  1146.  *    occurs then an error message is left in interp->result.
  1147.  *    The value of the expression is returned in *valuePtr, in
  1148.  *    whatever form it ends up in (could be string or integer
  1149.  *    or double).  Caller may need to convert result.  Caller
  1150.  *    is also responsible for freeing string memory in *valuePtr,
  1151.  *    if any was allocated.
  1152.  *
  1153.  * Side effects:
  1154.  *    None.
  1155.  *
  1156.  *--------------------------------------------------------------
  1157.  */
  1158.  
  1159. static int
  1160. ExprTopLevel(interp, string, valuePtr)
  1161.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1162.                      * expression. */
  1163.     char *string;            /* Expression to evaluate. */
  1164.     Value *valuePtr;            /* Where to store result.  Should
  1165.                      * not be initialized by caller. */
  1166. {
  1167.     ExprInfo info;
  1168.     int result;
  1169.  
  1170.     info.originalExpr = string;
  1171.     info.expr = string;
  1172.     valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace;
  1173.     valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1;
  1174.     valuePtr->pv.expandProc = TclExpandParseValue;
  1175.     valuePtr->pv.clientData = (ClientData) NULL;
  1176.  
  1177.     result = ExprGetValue(interp, &info, -1, valuePtr);
  1178.     if (result != TCL_OK) {
  1179.     return result;
  1180.     }
  1181.     if (info.token != END) {
  1182.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1183.         string, "\"", (char *) NULL);
  1184.     return TCL_ERROR;
  1185.     }
  1186.     return TCL_OK;
  1187. }
  1188.  
  1189. /*
  1190.  *--------------------------------------------------------------
  1191.  *
  1192.  * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
  1193.  *
  1194.  *    Procedures to evaluate an expression and return its value
  1195.  *    in a particular form.
  1196.  *
  1197.  * Results:
  1198.  *    Each of the procedures below returns a standard Tcl result.
  1199.  *    If an error occurs then an error message is left in
  1200.  *    interp->result.  Otherwise the value of the expression,
  1201.  *    in the appropriate form, is stored at *resultPtr.  If
  1202.  *    the expression had a result that was incompatible with the
  1203.  *    desired form then an error is returned.
  1204.  *
  1205.  * Side effects:
  1206.  *    None.
  1207.  *
  1208.  *--------------------------------------------------------------
  1209.  */
  1210.  
  1211. int
  1212. Tcl_ExprLong(interp, string, ptr)
  1213.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1214.                      * expression. */
  1215.     char *string;            /* Expression to evaluate. */
  1216.     long *ptr;                /* Where to store result. */
  1217. {
  1218.     Value value;
  1219.     int result;
  1220.  
  1221.     result = ExprTopLevel(interp, string, &value);
  1222.     if (result == TCL_OK) {
  1223.     if (value.type == TYPE_INT) {
  1224.         *ptr = value.intValue;
  1225.     } else if (value.type == TYPE_DOUBLE) {
  1226.         *ptr = value.doubleValue;
  1227.     } else {
  1228.         interp->result = "expression didn't have numeric value";
  1229.         result = TCL_ERROR;
  1230.     }
  1231.     }
  1232.     if (value.pv.buffer != value.staticSpace) {
  1233.     ckfree(value.pv.buffer);
  1234.     }
  1235.     return result;
  1236. }
  1237.  
  1238. int
  1239. Tcl_ExprDouble(interp, string, ptr)
  1240.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1241.                      * expression. */
  1242.     char *string;            /* Expression to evaluate. */
  1243.     double *ptr;            /* Where to store result. */
  1244. {
  1245.     Value value;
  1246.     int result;
  1247.  
  1248.     result = ExprTopLevel(interp, string, &value);
  1249.     if (result == TCL_OK) {
  1250.     if (value.type == TYPE_INT) {
  1251.         *ptr = value.intValue;
  1252.     } else if (value.type == TYPE_DOUBLE) {
  1253.         *ptr = value.doubleValue;
  1254.     } else {
  1255.         interp->result = "expression didn't have numeric value";
  1256.         result = TCL_ERROR;
  1257.     }
  1258.     }
  1259.     if (value.pv.buffer != value.staticSpace) {
  1260.     ckfree(value.pv.buffer);
  1261.     }
  1262.     return result;
  1263. }
  1264.  
  1265. int
  1266. Tcl_ExprBoolean(interp, string, ptr)
  1267.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1268.                      * expression. */
  1269.     char *string;            /* Expression to evaluate. */
  1270.     int *ptr;                /* Where to store 0/1 result. */
  1271. {
  1272.     Value value;
  1273.     int result;
  1274.  
  1275.     result = ExprTopLevel(interp, string, &value);
  1276.     if (result == TCL_OK) {
  1277.     if (value.type == TYPE_INT) {
  1278.         *ptr = value.intValue != 0;
  1279.     } else if (value.type == TYPE_DOUBLE) {
  1280.         *ptr = value.doubleValue != 0.0;
  1281.     } else {
  1282.         interp->result = "expression didn't have numeric value";
  1283.         result = TCL_ERROR;
  1284.     }
  1285.     }
  1286.     if (value.pv.buffer != value.staticSpace) {
  1287.     ckfree(value.pv.buffer);
  1288.     }
  1289.     return result;
  1290. }
  1291.  
  1292. /*
  1293.  *--------------------------------------------------------------
  1294.  *
  1295.  * Tcl_ExprString --
  1296.  *
  1297.  *    Evaluate an expression and return its value in string form.
  1298.  *
  1299.  * Results:
  1300.  *    A standard Tcl result.  If the result is TCL_OK, then the
  1301.  *    interpreter's result is set to the string value of the
  1302.  *    expression.  If the result is TCL_OK, then interp->result
  1303.  *    contains an error message.
  1304.  *
  1305.  * Side effects:
  1306.  *    None.
  1307.  *
  1308.  *--------------------------------------------------------------
  1309.  */
  1310.  
  1311. int
  1312. Tcl_ExprString(interp, string)
  1313.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1314.                      * expression. */
  1315.     char *string;            /* Expression to evaluate. */
  1316. {
  1317.     Value value;
  1318.     int result;
  1319.  
  1320.     result = ExprTopLevel(interp, string, &value);
  1321.     if (result == TCL_OK) {
  1322.     if (value.type == TYPE_INT) {
  1323.         sprintf(interp->result, "%ld", value.intValue);
  1324.     } else if (value.type == TYPE_DOUBLE) {
  1325.         sprintf(interp->result, "%g", value.doubleValue);
  1326.     } else {
  1327.         if (value.pv.buffer != value.staticSpace) {
  1328.         interp->result = value.pv.buffer;
  1329.         interp->freeProc = (Tcl_FreeProc *) free;
  1330.         value.pv.buffer = value.staticSpace;
  1331.         } else {
  1332.         Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE);
  1333.         }
  1334.     }
  1335.     }
  1336.     if (value.pv.buffer != value.staticSpace) {
  1337.     ckfree(value.pv.buffer);
  1338.     }
  1339.     return result;
  1340. }
  1341.